home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / bin / intltool-extract < prev    next >
Text File  |  2005-10-18  |  22KB  |  840 lines
  1. #!/usr/bin/perl -w 
  2. # -*- Mode: perl; indent-tabs-mode: nil; c-basic-offset: 4  -*-
  3.  
  4. #
  5. #  The Intltool Message Extractor
  6. #
  7. #  Copyright (C) 2000-2001, 2003 Free Software Foundation.
  8. #
  9. #  Intltool is free software; you can redistribute it and/or
  10. #  modify it under the terms of the GNU General Public License as
  11. #  published by the Free Software Foundation; either version 2 of the
  12. #  License, or (at your option) any later version.
  13. #
  14. #  Intltool is distributed in the hope that it will be useful,
  15. #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17. #  General Public License for more details.
  18. #
  19. #  You should have received a copy of the GNU General Public License
  20. #  along with this program; if not, write to the Free Software
  21. #  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22. #
  23. #  As a special exception to the GNU General Public License, if you
  24. #  distribute this file as part of a program that contains a
  25. #  configuration script generated by Autoconf, you may include it under
  26. #  the same distribution terms that you use for the rest of that program.
  27. #
  28. #  Authors: Kenneth Christiansen <kenneth@gnu.org>
  29. #           Darin Adler <darin@bentspoon.com>
  30. #
  31.  
  32. ## Release information
  33. my $PROGRAM      = "intltool-extract";
  34. my $PACKAGE      = "intltool";
  35. my $VERSION      = "0.34.1";
  36.  
  37. ## Loaded modules
  38. use strict; 
  39. use File::Basename;
  40. use Getopt::Long;
  41.  
  42. ## Scalars used by the option stuff
  43. my $TYPE_ARG    = "0";
  44. my $LOCAL_ARG    = "0";
  45. my $HELP_ARG     = "0";
  46. my $VERSION_ARG = "0";
  47. my $UPDATE_ARG  = "0";
  48. my $QUIET_ARG   = "0";
  49. my $SRCDIR_ARG    = ".";
  50.  
  51. my $FILE;
  52. my $OUTFILE;
  53.  
  54. my $gettext_type = "";
  55. my $input;
  56. my %messages = ();
  57. my %loc = ();
  58. my %count = ();
  59. my %comments = ();
  60. my $strcount = 0;
  61.  
  62. my $XMLCOMMENT = "";
  63.  
  64. ## Use this instead of \w for XML files to handle more possible characters.
  65. my $w = "[-A-Za-z0-9._:]";
  66.  
  67. ## Always print first
  68. $| = 1;
  69.  
  70. ## Handle options
  71. GetOptions (
  72.         "type=s"     => \$TYPE_ARG,
  73.             "local|l"    => \$LOCAL_ARG,
  74.             "help|h"     => \$HELP_ARG,
  75.             "version|v"  => \$VERSION_ARG,
  76.             "update"     => \$UPDATE_ARG,
  77.         "quiet|q"    => \$QUIET_ARG,
  78.         "srcdir=s"     => \$SRCDIR_ARG,
  79.             ) or &error;
  80.  
  81. &split_on_argument;
  82.  
  83.  
  84. ## Check for options. 
  85. ## This section will check for the different options.
  86.  
  87. sub split_on_argument {
  88.  
  89.     if ($VERSION_ARG) {
  90.         &version;
  91.  
  92.     } elsif ($HELP_ARG) {
  93.     &help;
  94.         
  95.     } elsif ($LOCAL_ARG) {
  96.         &place_local;
  97.         &extract;
  98.  
  99.     } elsif ($UPDATE_ARG) {
  100.     &place_normal;
  101.     &extract;
  102.  
  103.     } elsif (@ARGV > 0) {
  104.     &place_normal;
  105.     &message;
  106.     &extract;
  107.  
  108.     } else {
  109.     &help;
  110.  
  111.     }  
  112. }    
  113.  
  114. sub place_normal {
  115.     $FILE     = $ARGV[0];
  116.     $OUTFILE     = "$FILE.h";
  117. }   
  118.  
  119. sub place_local {
  120.     $FILE     = $ARGV[0];
  121.     $OUTFILE     = fileparse($FILE, ());
  122.     if (!-e "tmp/") { 
  123.         system("mkdir tmp/"); 
  124.     }
  125.     $OUTFILE     = "./tmp/$OUTFILE.h"
  126. }
  127.  
  128. sub determine_type {
  129.    if ($TYPE_ARG =~ /^gettext\/(.*)/) {
  130.     $gettext_type=$1
  131.    }
  132. }
  133.  
  134. ## Sub for printing release information
  135. sub version{
  136.     print <<_EOF_;
  137. ${PROGRAM} (${PACKAGE}) $VERSION
  138. Copyright (C) 2000, 2003 Free Software Foundation, Inc.
  139. Written by Kenneth Christiansen, 2000.
  140.  
  141. This is free software; see the source for copying conditions.  There is NO
  142. warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  143. _EOF_
  144.     exit;
  145. }
  146.  
  147. ## Sub for printing usage information
  148. sub help {
  149.     print <<_EOF_;
  150. Usage: ${PROGRAM} [OPTION]... [FILENAME]
  151. Generates a header file from an XML source file.
  152.  
  153. It grabs all strings between <_translatable_node> and its end tag in
  154. XML files. Read manpage (man ${PROGRAM}) for more info.
  155.  
  156.       --type=TYPE   Specify the file type of FILENAME. Currently supports:
  157.                     "gettext/glade", "gettext/ini", "gettext/keys"
  158.                     "gettext/rfc822deb", "gettext/schemas",
  159.                     "gettext/scheme", "gettext/xml"
  160.   -l, --local       Writes output into current working directory
  161.                     (conflicts with --update)
  162.       --update      Writes output into the same directory the source file 
  163.                     reside (conflicts with --local)
  164.       --srcdir      Root of the source tree
  165.   -v, --version     Output version information and exit
  166.   -h, --help        Display this help and exit
  167.   -q, --quiet       Quiet mode
  168.  
  169. Report bugs to http://bugzilla.gnome.org/ (product name "$PACKAGE")
  170. or send email to <xml-i18n-tools\@gnome.org>.
  171. _EOF_
  172.     exit;
  173. }
  174.  
  175. ## Sub for printing error messages
  176. sub error{
  177.     print STDERR "Try `${PROGRAM} --help' for more information.\n";
  178.     exit;
  179. }
  180.  
  181. sub message {
  182.     print "Generating C format header file for translation.\n" unless $QUIET_ARG;
  183. }
  184.  
  185. sub extract {
  186.     &determine_type;
  187.  
  188.     &convert;
  189.  
  190.     open OUT, ">$OUTFILE";
  191.     binmode (OUT) if $^O eq 'MSWin32';
  192.     &msg_write;
  193.     close OUT;
  194.  
  195.     print "Wrote $OUTFILE\n" unless $QUIET_ARG;
  196. }
  197.  
  198. sub convert {
  199.  
  200.     ## Reading the file
  201.     {
  202.     local (*IN);
  203.     local $/; #slurp mode
  204.     open (IN, "<$SRCDIR_ARG/$FILE") || die "can't open $SRCDIR_ARG/$FILE: $!";
  205.     $input = <IN>;
  206.     }
  207.  
  208.     &type_ini if $gettext_type eq "ini";
  209.     &type_keys if $gettext_type eq "keys";
  210.     &type_xml if $gettext_type eq "xml";
  211.     &type_glade if $gettext_type eq "glade";
  212.     &type_scheme if $gettext_type eq "scheme";
  213.     &type_schemas  if $gettext_type eq "schemas";
  214.     &type_rfc822deb  if $gettext_type eq "rfc822deb";
  215. }
  216.  
  217. sub entity_decode_minimal
  218. {
  219.     local ($_) = @_;
  220.  
  221.     s/'/'/g; # '
  222.     s/"/"/g; # "
  223.     s/&/&/g;
  224.  
  225.     return $_;
  226. }
  227.  
  228. sub entity_decode
  229. {
  230.     local ($_) = @_;
  231.  
  232.     s/'/'/g; # '
  233.     s/"/"/g; # "
  234.     s/&/&/g;
  235.     s/</</g;
  236.     s/>/>/g;
  237.  
  238.     return $_;
  239. }
  240.  
  241. sub escape_char
  242. {
  243.     return '\"' if $_ eq '"';
  244.     return '\n' if $_ eq "\n";
  245.     return '\\' if $_ eq '\\';
  246.  
  247.     return $_;
  248. }
  249.  
  250. sub escape
  251. {
  252.     my ($string) = @_;
  253.     return join "", map &escape_char, split //, $string;
  254. }
  255.  
  256. sub type_ini {
  257.     ### For generic translatable desktop files ###
  258.     while ($input =~ /^_.*=(.*)$/mg) {
  259.         $messages{$1} = [];
  260.     }
  261. }
  262.  
  263. sub type_keys {
  264.     ### For generic translatable mime/keys files ###
  265.     while ($input =~ /^\s*_\w+=(.*)$/mg) {
  266.         $messages{$1} = [];
  267.     }
  268. }
  269.  
  270. sub type_xml {
  271.     ### For generic translatable XML files ###
  272.     my $tree = readXml($input);
  273.     parseTree(0, $tree);
  274. }
  275.  
  276. sub print_var {
  277.     my $var = shift;
  278.     my $vartype = ref $var;
  279.     
  280.     if ($vartype =~ /ARRAY/) {
  281.         my @arr = @{$var};
  282.         print "[ ";
  283.         foreach my $el (@arr) {
  284.             print_var($el);
  285.             print ", ";
  286.         }
  287.         print "] ";
  288.     } elsif ($vartype =~ /HASH/) {
  289.         my %hash = %{$var};
  290.         print "{ ";
  291.         foreach my $key (keys %hash) {
  292.             print "$key => ";
  293.             print_var($hash{$key});
  294.             print ", ";
  295.         }
  296.         print "} ";
  297.     } else {
  298.         print $var;
  299.     }
  300. }
  301.  
  302. # Same syntax as getAttributeString in intltool-merge.in.in, similar logic (look for ## differences comment)
  303. sub getAttributeString
  304. {
  305.     my $sub = shift;
  306.     my $do_translate = shift || 1;
  307.     my $language = shift || "";
  308.     my $translate = shift;
  309.     my $result = "";
  310.     foreach my $e (reverse(sort(keys %{ $sub }))) {
  311.     my $key    = $e;
  312.     my $string = $sub->{$e};
  313.     my $quote = '"';
  314.     
  315.     $string =~ s/^[\s]+//;
  316.     $string =~ s/[\s]+$//;
  317.     
  318.     if ($string =~ /^'.*'$/)
  319.     {
  320.         $quote = "'";
  321.     }
  322.     $string =~ s/^['"]//g;
  323.     $string =~ s/['"]$//g;
  324.  
  325.         ## differences from intltool-merge.in.in
  326.     if ($key =~ /^_/) {
  327.             $comments{entity_decode($string)} = $XMLCOMMENT if $XMLCOMMENT;
  328.             $messages{entity_decode($string)} = [];
  329.             $$translate = 2;
  330.     }
  331.         ## differences end here from intltool-merge.in.in
  332.     $result .= " $key=$quote$string$quote";
  333.     }
  334.     return $result;
  335. }
  336.  
  337. # Verbatim copy from intltool-merge.in.in
  338. sub getXMLstring
  339. {
  340.     my $ref = shift;
  341.     my $spacepreserve = shift || 0;
  342.     my @list = @{ $ref };
  343.     my $result = "";
  344.  
  345.     my $count = scalar(@list);
  346.     my $attrs = $list[0];
  347.     my $index = 1;
  348.  
  349.     $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  350.     $spacepreserve = 0 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?default["']?$/));
  351.  
  352.     while ($index < $count) {
  353.     my $type = $list[$index];
  354.     my $content = $list[$index+1];
  355.         if (! $type ) {
  356.         # We've got CDATA
  357.         if ($content) {
  358.         # lets strip the whitespace here, and *ONLY* here
  359.                 $content =~ s/\s+/ /gs if (!$spacepreserve);
  360.         $result .= $content;
  361.         }
  362.     } elsif ( "$type" ne "1" ) {
  363.         # We've got another element
  364.         $result .= "<$type";
  365.         $result .= getAttributeString(@{$content}[0], 0); # no nested translatable elements
  366.         if ($content) {
  367.         my $subresult = getXMLstring($content, $spacepreserve);
  368.         if ($subresult) {
  369.             $result .= ">".$subresult . "</$type>";
  370.         } else {
  371.             $result .= "/>";
  372.         }
  373.         } else {
  374.         $result .= "/>";
  375.         }
  376.     }
  377.     $index += 2;
  378.     }
  379.     return $result;
  380. }
  381.  
  382. # Verbatim copy from intltool-merge.in.in, except for MULTIPLE_OUTPUT handling removed
  383. # Translate list of nodes if necessary
  384. sub translate_subnodes
  385. {
  386.     my $fh = shift;
  387.     my $content = shift;
  388.     my $language = shift || "";
  389.     my $singlelang = shift || 0;
  390.     my $spacepreserve = shift || 0;
  391.  
  392.     my @nodes = @{ $content };
  393.  
  394.     my $count = scalar(@nodes);
  395.     my $index = 0;
  396.     while ($index < $count) {
  397.         my $type = $nodes[$index];
  398.         my $rest = $nodes[$index+1];
  399.         traverse($fh, $type, $rest, $language, $spacepreserve);
  400.         $index += 2;
  401.     }
  402. }
  403.  
  404. # Based on traverse() in intltool-merge.in.in
  405. sub traverse
  406. {
  407.     my $fh = shift; # unused, to allow us to sync code between -merge and -extract
  408.     my $nodename = shift;
  409.     my $content = shift;
  410.     my $language = shift || "";
  411.     my $spacepreserve = shift || 0;
  412.  
  413.     if ($nodename && "$nodename" eq "1") {
  414.         $XMLCOMMENT = $content;
  415.     } elsif ($nodename) {
  416.     # element
  417.     my @all = @{ $content };
  418.     my $attrs = shift @all;
  419.     my $translate = 0;
  420.     my $outattr = getAttributeString($attrs, 1, $language, \$translate);
  421.  
  422.     if ($nodename =~ /^_/) {
  423.         $translate = 1;
  424.         $nodename =~ s/^_//;
  425.     }
  426.     my $lookup = '';
  427.  
  428.         $spacepreserve = 0 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?default["']?$/));
  429.         $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  430.  
  431.     if ($translate) {
  432.         $lookup = getXMLstring($content, $spacepreserve);
  433.             if (!$spacepreserve) {
  434.                 $lookup =~ s/^\s+//s;
  435.                 $lookup =~ s/\s+$//s;
  436.             }
  437.  
  438.         if ($lookup && $translate != 2) {
  439.                 $comments{$lookup} = $XMLCOMMENT if $XMLCOMMENT;
  440.                 $messages{$lookup} = [];
  441.             } elsif ($translate == 2) {
  442.                 translate_subnodes($fh, \@all, $language, 1, $spacepreserve);
  443.         }
  444.     } else {
  445.             $XMLCOMMENT = "";
  446.         my $count = scalar(@all);
  447.         if ($count > 0) {
  448.                 my $index = 0;
  449.                 while ($index < $count) {
  450.                     my $type = $all[$index];
  451.                     my $rest = $all[$index+1];
  452.                     traverse($fh, $type, $rest, $language, $spacepreserve);
  453.                     $index += 2;
  454.                 }
  455.         }
  456.     }
  457.         $XMLCOMMENT = "";
  458.     }
  459. }
  460.  
  461.  
  462. # Verbatim copy from intltool-merge.in.in, $fh for compatibility
  463. sub parseTree
  464. {
  465.     my $fh        = shift;
  466.     my $ref       = shift;
  467.     my $language  = shift || "";
  468.  
  469.     my $name = shift @{ $ref };
  470.     my $cont = shift @{ $ref };
  471.  
  472.     while (!$name || "$name" eq "1") {
  473.         $name = shift @{ $ref };
  474.         $cont = shift @{ $ref };
  475.     }
  476.  
  477.     my $spacepreserve = 0;
  478.     my $attrs = @{$cont}[0];
  479.     $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  480.  
  481.     traverse($fh, $name, $cont, $language, $spacepreserve);
  482. }
  483.  
  484. # Verbatim copy from intltool-merge.in.in
  485. sub intltool_tree_comment
  486. {
  487.     my $expat = shift;
  488.     my $data  = shift;
  489.     my $clist = $expat->{Curlist};
  490.     my $pos   = $#$clist;
  491.  
  492.     push @$clist, 1 => $data;
  493. }
  494.  
  495. # Verbatim copy from intltool-merge.in.in
  496. sub intltool_tree_cdatastart
  497. {
  498.     my $expat    = shift;
  499.     my $clist = $expat->{Curlist};
  500.     my $pos   = $#$clist;
  501.  
  502.     push @$clist, 0 => $expat->original_string();
  503. }
  504.  
  505. # Verbatim copy from intltool-merge.in.in
  506. sub intltool_tree_cdataend
  507. {
  508.     my $expat    = shift;
  509.     my $clist = $expat->{Curlist};
  510.     my $pos   = $#$clist;
  511.  
  512.     $clist->[$pos] .= $expat->original_string();
  513. }
  514.  
  515. # Verbatim copy from intltool-merge.in.in
  516. sub intltool_tree_char
  517. {
  518.     my $expat = shift;
  519.     my $text  = shift;
  520.     my $clist = $expat->{Curlist};
  521.     my $pos   = $#$clist;
  522.  
  523.     # Use original_string so that we retain escaped entities
  524.     # in CDATA sections.
  525.     #
  526.     if ($pos > 0 and $clist->[$pos - 1] eq '0') {
  527.         $clist->[$pos] .= $expat->original_string();
  528.     } else {
  529.         push @$clist, 0 => $expat->original_string();
  530.     }
  531. }
  532.  
  533. # Verbatim copy from intltool-merge.in.in
  534. sub intltool_tree_start
  535. {
  536.     my $expat    = shift;
  537.     my $tag      = shift;
  538.     my @origlist = ();
  539.  
  540.     # Use original_string so that we retain escaped entities
  541.     # in attribute values.  We must convert the string to an
  542.     # @origlist array to conform to the structure of the Tree
  543.     # Style.
  544.     #
  545.     my @original_array = split /\x/, $expat->original_string();
  546.     my $source         = $expat->original_string();
  547.  
  548.     # Remove leading tag.
  549.     #
  550.     $source =~ s|^\s*<\s*(\S+)||s;
  551.  
  552.     # Grab attribute key/value pairs and push onto @origlist array.
  553.     #
  554.     while ($source)
  555.     {
  556.        if ($source =~ /^\s*([\w:-]+)\s*[=]\s*["]/)
  557.        {
  558.            $source =~ s|^\s*([\w:-]+)\s*[=]\s*["]([^"]*)["]||s;
  559.            push @origlist, $1;
  560.            push @origlist, '"' . $2 . '"';
  561.        }
  562.        elsif ($source =~ /^\s*([\w:-]+)\s*[=]\s*[']/)
  563.        {
  564.            $source =~ s|^\s*([\w:-]+)\s*[=]\s*[']([^']*)[']||s;
  565.            push @origlist, $1;
  566.            push @origlist, "'" . $2 . "'";
  567.        }
  568.        else
  569.        {
  570.            last;
  571.        }
  572.     }
  573.  
  574.     my $ol = [ { @origlist } ];
  575.  
  576.     push @{ $expat->{Lists} }, $expat->{Curlist};
  577.     push @{ $expat->{Curlist} }, $tag => $ol;
  578.     $expat->{Curlist} = $ol;
  579. }
  580.  
  581. # Copied from intltool-merge.in.in and added comment handler.
  582. sub readXml
  583. {
  584.     my $xmldoc = shift || return;
  585.     my $ret = eval 'require XML::Parser';
  586.     if(!$ret) {
  587.         die "You must have XML::Parser installed to run $0\n\n";
  588.     }
  589.     my $xp = new XML::Parser(Style => 'Tree');
  590.     $xp->setHandlers(Char => \&intltool_tree_char);
  591.     $xp->setHandlers(Start => \&intltool_tree_start);
  592.     $xp->setHandlers(CdataStart => \&intltool_tree_cdatastart);
  593.     $xp->setHandlers(CdataEnd => \&intltool_tree_cdataend);
  594.  
  595.     ## differences from intltool-merge.in.in
  596.     $xp->setHandlers(Comment => \&intltool_tree_comment);
  597.     ## differences end here from intltool-merge.in.in
  598.  
  599.     my $tree = $xp->parse($xmldoc);
  600.     #print_var($tree);
  601.  
  602. # <foo><!-- comment --><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo>
  603. # would be:
  604. # [foo, [{}, 1, "comment", head, [{id => "a"}, 0, "Hello ",  em, [{}, 0, "there"]], bar, 
  605. # [{}, 0, "Howdy",  ref, [{}]], 0, "do" ] ]
  606.  
  607.     return $tree;
  608. }
  609.  
  610. sub type_schemas {
  611.     ### For schemas XML files ###
  612.          
  613.     # FIXME: We should handle escaped < (less than)
  614.     while ($input =~ /
  615.                       <locale\ name="C">\s*
  616.                           (<default>\s*(?:<!--([^>]*?)-->\s*)?(.*?)\s*<\/default>\s*)?
  617.                           (<short>\s*(?:<!--([^>]*?)-->\s*)?(.*?)\s*<\/short>\s*)?
  618.                           (<long>\s*(?:<!--([^>]*?)-->\s*)?(.*?)\s*<\/long>\s*)?
  619.                       <\/locale>
  620.                      /sgx) {
  621.         my @totranslate = ($3,$6,$9);
  622.         my @eachcomment = ($2,$5,$8);
  623.         foreach (@totranslate) {
  624.             my $currentcomment = shift @eachcomment;
  625.             next if !$_;
  626.             s/\s+/ /g;
  627.             $messages{entity_decode_minimal($_)} = [];
  628.             $comments{entity_decode_minimal($_)} = $currentcomment if (defined($currentcomment));
  629.         }
  630.     }
  631. }
  632.  
  633. sub type_rfc822deb {
  634.     ### For rfc822-style Debian configuration files ###
  635.  
  636.     my $lineno = 1;
  637.     my $type = '';
  638.     while ($input =~ /\G(.*?)(^|\n)(_+)([^:]+):[ \t]*(.*?)(?=\n\S|$)/sg)
  639.     {
  640.         my ($pre, $newline, $underscore, $tag, $text) = ($1, $2, $3, $4, $5);
  641.         while ($pre =~ m/\n/g)
  642.         {
  643.             $lineno ++;
  644.         }
  645.         $lineno += length($newline);
  646.         my @str_list = rfc822deb_split(length($underscore), $text);
  647.         for my $str (@str_list)
  648.         {
  649.             $strcount++;
  650.             $messages{$str} = [];
  651.             $loc{$str} = $lineno;
  652.             $count{$str} = $strcount;
  653.             my $usercomment = '';
  654.             while($pre =~ s/(^|\n)#([^\n]*)$//s)
  655.             {
  656.                 $usercomment = "\n" . $2 . $usercomment;
  657.             }
  658.             $comments{$str} = $tag . $usercomment;
  659.         }
  660.         $lineno += ($text =~ s/\n//g);
  661.     }
  662. }
  663.  
  664. sub rfc822deb_split {
  665.     # Debian defines a special way to deal with rfc822-style files:
  666.     # when a value contain newlines, it consists of
  667.     #   1.  a short form (first line)
  668.     #   2.  a long description, all lines begin with a space,
  669.     #       and paragraphs are separated by a single dot on a line
  670.     # This routine returns an array of all paragraphs, and reformat
  671.     # them.
  672.     # When first argument is 2, the string is a comma separated list of
  673.     # values.
  674.     my $type = shift;
  675.     my $text = shift;
  676.     $text =~ s/^[ \t]//mg;
  677.     return (split(/, */, $text, 0)) if $type ne 1;
  678.     return ($text) if $text !~ /\n/;
  679.  
  680.     $text =~ s/([^\n]*)\n//;
  681.     my @list = ($1);
  682.     my $str = '';
  683.     for my $line (split (/\n/, $text))
  684.     {
  685.         chomp $line;
  686.         if ($line =~ /^\.\s*$/)
  687.         {
  688.             #  New paragraph
  689.             $str =~ s/\s*$//;
  690.             push(@list, $str);
  691.             $str = '';
  692.         }
  693.         elsif ($line =~ /^\s/)
  694.         {
  695.             #  Line which must not be reformatted
  696.             $str .= "\n" if length ($str) && $str !~ /\n$/;
  697.             $line =~ s/\s+$//;
  698.             $str .= $line."\n";
  699.         }
  700.         else
  701.         {
  702.             #  Continuation line, remove newline
  703.             $str .= " " if length ($str) && $str !~ /\n$/;
  704.             $str .= $line;
  705.         }
  706.     }
  707.     $str =~ s/\s*$//;
  708.     push(@list, $str) if length ($str);
  709.     return @list;
  710. }
  711.  
  712. sub type_glade {
  713.     ### For translatable Glade XML files ###
  714.  
  715.     my $tags = "label|title|text|format|copyright|comments|preview_text|tooltip|message";
  716.  
  717.     while ($input =~ /<($tags)>([^<]+)<\/($tags)>/sg) {
  718.     # Glade sometimes uses tags that normally mark translatable things for
  719.         # little bits of non-translatable content. We work around this by not
  720.         # translating strings that only includes something like label4 or window1.
  721.     $messages{entity_decode($2)} = [] unless $2 =~ /^(window|label|dialog)[0-9]+$/;
  722.     }
  723.     
  724.     while ($input =~ /<items>(..[^<]*)<\/items>/sg) {
  725.     for my $item (split (/\n/, $1)) {
  726.         $messages{entity_decode($item)} = [];
  727.     }
  728.     }
  729.  
  730.     ## handle new glade files
  731.     while ($input =~ /<(property|atkproperty)\s+[^>]*translatable\s*=\s*"yes"(?:\s+[^>]*comments\s*=\s*"([^"]*)")?[^>]*>([^<]+)<\/\1>/sg) {
  732.     $messages{entity_decode($3)} = [] unless $3 =~ /^(window|label)[0-9]+$/;
  733.         if (defined($2) and !($3 =~ /^(window|label)[0-9]+$/)) {
  734.        $comments{entity_decode($3)} = entity_decode($2) ;
  735.         }
  736.     }
  737.     while ($input =~ /<atkaction\s+action_name="([^>]*)"\s+description="([^>]+)"\/>/sg) {
  738.         $messages{entity_decode_minimal($2)} = [];
  739.     }
  740. }
  741.  
  742. sub type_scheme {
  743.     my ($line, $i, $state, $str, $trcomment, $char);
  744.     for $line (split(/\n/, $input)) {
  745.         $i = 0;
  746.         $state = 0; # 0 - nothing, 1 - string, 2 - translatable string
  747.         while ($i < length($line)) {
  748.             if (substr($line,$i,1) eq "\"") {
  749.                 if ($state == 2) {
  750.                     $comments{$str} = $trcomment if ($trcomment);
  751.                     $messages{$str} = [];
  752.                     $str = '';
  753.                     $state = 0; $trcomment = "";
  754.                 } elsif ($state == 1) {
  755.                     $str = '';
  756.                     $state = 0; $trcomment = "";
  757.                 } else {
  758.                     $state = 1;
  759.                     $str = '';
  760.                     if ($i>0 && substr($line,$i-1,1) eq '_') {
  761.                         $state = 2;
  762.                     }
  763.                 }
  764.             } elsif (!$state) {
  765.                 if (substr($line,$i,1) eq ";") {
  766.                     $trcomment = substr($line,$i+1);
  767.                     $trcomment =~ s/^;*\s*//;
  768.                     $i = length($line);
  769.                 } elsif ($trcomment && substr($line,$i,1) !~ /\s|\(|\)|_/) {
  770.                     $trcomment = "";
  771.                 }
  772.             } else {
  773.                 if (substr($line,$i,1) eq "\\") {
  774.                     $char = substr($line,$i+1,1);
  775.                     if ($char ne "\"" && $char ne "\\") {
  776.                        $str = $str . "\\";
  777.                     }
  778.                     $i++;
  779.                 }
  780.                 $str = $str . substr($line,$i,1);
  781.             }
  782.             $i++;
  783.         }
  784.     }
  785. }
  786.  
  787. sub msg_write {
  788.     my @msgids;
  789.     if (%count)
  790.     {
  791.         @msgids = sort { $count{$a} <=> $count{$b} } keys %count;
  792.     }
  793.     else
  794.     {
  795.         @msgids = sort keys %messages;
  796.     }
  797.     for my $message (@msgids)
  798.     {
  799.     my $offsetlines = 1;
  800.     $offsetlines++ if $message =~ /%/;
  801.     if (defined ($comments{$message}))
  802.     {
  803.         while ($comments{$message} =~ m/\n/g)
  804.         {
  805.             $offsetlines++;
  806.         }
  807.     }
  808.     print OUT "# ".($loc{$message} - $offsetlines).  " \"$FILE\"\n"
  809.             if defined $loc{$message};
  810.        print OUT "/* ".$comments{$message}." */\n"
  811.                 if defined $comments{$message};
  812.        print OUT "/* xgettext:no-c-format */\n" if $message =~ /%/;
  813.         
  814.         my @lines = split (/\n/, $message, -1);
  815.         for (my $n = 0; $n < @lines; $n++)
  816.     {
  817.             if ($n == 0)
  818.             {
  819.          print OUT "char *s = N_(\""; 
  820.             }
  821.             else
  822.             {  
  823.                 print OUT "             \""; 
  824.             }
  825.  
  826.             print OUT escape($lines[$n]);
  827.  
  828.             if ($n < @lines - 1)
  829.             {
  830.                 print OUT "\\n\"\n"; 
  831.             }
  832.             else
  833.             {
  834.                 print OUT "\");\n";  
  835.         }
  836.         }
  837.     }
  838. }
  839.  
  840.